home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 60.zip / BS1 part 60 / Highspeed pascal.adf / Demos / Print.pas < prev    next >
Pascal/Delphi Source File  |  1991-12-31  |  9KB  |  296 lines
  1. {----------------------------------------------------------------------}
  2. {                      HighSpeed Pascal Demo Program                   }
  3. {                                                                      }
  4. {              Copyright (C) 1990 by D-House I Aps, Denmark            }
  5. {                                                                      }
  6. {                     Programmed by Jacob V. Pedersen                  }
  7. {                                                                      }
  8. {                                                                      }
  9. { The program: Prints your Pascal programs (source-code). Any include  }
  10. {              files are also loaded and printed. Remarks can be dis-  }
  11. {              carded when printing.                                   }
  12. {----------------------------------------------------------------------}
  13. Program Print;
  14.  
  15. Uses Printer,Dos;
  16.  
  17. Const
  18.         TopMargin       =    2;      { Top margin }
  19.         PrintLines      =   59;      { Lines to print per page }
  20.         BottomMargin    =   11;      { Bottom margin }
  21.         PageLines       =   72;      { Adds up to total lines per page }
  22.         MaxIncludeLevel =    7;      { 0 is the same as IncLoad=False }
  23.         RemShow         =False;      { Show remarks? }
  24.         LinShow         =False;      { Show line numbers? }
  25.         IncLoad         = True;      { Load include files? }
  26. Var
  27.         LineNum         : Integer;   { Line counter. Total }
  28.         PageCount       : Byte;      { Line counter. Page }
  29.         IncludeLevel    : Byte;      { Include-file level }
  30.  
  31.  
  32. { Main procedure to process the primary file, as well as any }
  33. { found include files.                                       }
  34. Procedure Process_File(Fil : PathStr; FirstFile : Boolean);
  35. Var
  36.         InFil      : Text;      { Input file }
  37.         Ch         ,            { Current character }
  38.         PrevCh     : Char;      { Previous character }
  39.         Buffer     ,            { Buffer for output }
  40.         Data       : String;    { Line read from file }
  41.         LinePos    : Byte;      { Current position on line }
  42.         StrExp     ,            { Currently in a strig expression? }
  43.         IgnoreStr  ,            { Used in connection with StrExp }
  44.         In_Remark  ,            { Currently in a remark? }
  45.         FirstLine,              { First line in file? }
  46.         NormChr    : Boolean;   { Is there a character on the line? }
  47.  
  48.  
  49. { Stuffs characters into the output stream }
  50. Procedure OutPut(C : Char);
  51. Begin
  52.   If In_Remark and Not(RemShow) then Exit;
  53.   Buffer := Buffer + C;
  54.   If (C > #32) then
  55.     NormChr := True;
  56. End;
  57.  
  58.  
  59. { Print a line to the output file }
  60. Procedure PrintLine;
  61. Var
  62.         X       : Byte;
  63.  
  64. { Returns true if no characters are present in the output stream }
  65. Function EmptyLine : Boolean;
  66. Var X : Byte;
  67. Begin
  68.   For X := 1 to Length(Data) Do
  69.     If Data[x] <> #32 then
  70.       Begin
  71.         EmptyLine := False;
  72.         Exit;
  73.       End;
  74.   EmptyLine := True;
  75. End;
  76.  
  77.  
  78. { Takes care of top and bottom margins }
  79. Procedure MakeMargin(Lines : Byte);
  80. Var
  81.         X : Byte;
  82. Begin
  83.   For X := 1 to Lines Do
  84.     WriteLn(Lst);
  85. End;
  86.  
  87.  
  88. Begin { PrintLine }
  89.   If (NormChr or EmptyLine) and Not(FirstLine) then
  90.     Begin
  91.       If (PageCount = 0) then
  92.         MakeMargin(TopMargin)
  93.       Else
  94.       If (PageCount = PrintLines) then
  95.         Begin
  96.           MakeMargin(BottomMargin);
  97.           MakeMargin(TopMargin);
  98.           PageCount := 0;
  99.        End;           
  100.       Inc(PageCount);
  101.       If LinShow then
  102.         Begin
  103.           Inc(LineNum);
  104.           Write(Lst,LineNum:5,',',IncludeLevel,': ');
  105.         End;              
  106.       Writeln(Lst,Buffer);
  107.     End;
  108.   Buffer := '';
  109. End; { PrintLine }
  110.  
  111.  
  112. { Provides the next character in the input stream }
  113. Procedure NextCh;
  114. Begin
  115.   PrevCh := Ch;
  116.   If LinePos = Length(Data) then
  117.     Begin
  118.       LinePos := 0;
  119.       PrintLine;
  120.       ReadLn(InFil,Data);
  121.       FirstLine := In_Remark and Not(RemShow);
  122.       NormChr   := False;
  123.       Ch        := #0;
  124.     End
  125.   Else
  126.     Begin
  127.       Inc(LinePos);
  128.       Ch := Data[LinePos];
  129.     End;
  130. End; { NextCh }
  131.  
  132.  
  133. { Looks ahead in the input stream. Used to determine if a character }
  134. { is the start of a remark or a compiler directive                  }
  135. Function LookAhead(Chars : Byte) : Char;
  136. Begin
  137.   If LinePos+Chars <= Length(Data) then
  138.     LookAhead := Data[LinePos+Chars]
  139.   Else
  140.     LookAhead := #0;
  141. End; { LookAhead }
  142.  
  143.  
  144. { Reads and processes any remarks found in the input stream }
  145. Procedure Process_Remark;
  146. Begin
  147.   In_Remark := True;
  148.   OutPut(Ch);
  149.   Case Ch Of
  150.     '{' : Repeat
  151.             NextCh; OutPut(Ch);
  152.           Until (Ch = '}');
  153.     '(' : Repeat
  154.             NextCh; OutPut(Ch);
  155.           Until (PrevCh = '*') and (Ch = ')');
  156.   End;
  157.   In_Remark := False;
  158. End; { Process_Remark }
  159.  
  160.  
  161. { Reads and processes compiler directives. If IncLoad is True, then }
  162. { include files are processed by calling Process_File recursively   }
  163. Procedure Process_Directive;
  164. Var
  165.         OldPos  : Byte;
  166.         Navn    : PathStr;
  167.         Stop    : Char;
  168. Begin
  169.   If IncLoad then
  170.     Begin
  171.       OldPos := LinePos;
  172.       If Ch = '{' then
  173.         Stop := '}' Else Stop := '*';
  174.       While PrevCh <> '$' Do
  175.         NextCh;    
  176.       If (UpCase(Ch) = 'I') then
  177.         Begin
  178.           NextCh;
  179.           If (Ch = #32) then
  180.             Begin
  181.               Navn := '';
  182.               Repeat
  183.                 NextCh;
  184.                 If (Ch <> #32) and (Ch <> Stop) then
  185.                   Navn := Navn + Ch;
  186.               Until (Ch = Stop);
  187.               If Ch = '*' then
  188.                 NextCh;
  189.               Process_File(Navn,False);
  190.               Exit;
  191.             End;
  192.         End;
  193.       LinePos := OldPos;
  194.       OutPut(Data[LinePos]);
  195.     End { IncLoad }
  196.   Else
  197.     OutPut(Ch);
  198. End; { Process_Directive }
  199.  
  200.  
  201. Begin { Process_File }
  202.   If (IncludeLevel <= MaxIncludeLevel) Then     { Check include level }
  203.     Begin
  204.       If (Pos('.',Fil) = 0) then
  205.         Fil := Fil + '.PAS';                   { Check file extension }
  206.       Assign(InFil,Fil);
  207.       {$I-}
  208.       Reset(InFil);                            { Try to open the file }
  209.       {$I+}
  210.       If IOresult = 0 then            { File exists. Begin processing }
  211.         Begin
  212.           If FirstFile then            { If beginning of new printout }
  213.             Begin
  214.               LineNum      := 0;          { then reset some variables }
  215.               PageCount    := 0;
  216.               IncludeLevel := 0;
  217.             End;
  218.  
  219.           Inc(IncludeLevel);
  220.           FirstLine := True;
  221.           In_Remark := False;
  222.           StrExp    := False;
  223.           IgnoreStr := False;
  224.           Ch        := #0;
  225.           Data      := '';
  226.           LinePos   := 0;
  227.           Repeat
  228.             NextCh;
  229.             If Not(In_Remark) and (PrevCh = '''') then
  230.               Begin
  231.                 If (Ch = '''') then
  232.                   IgnoreStr := True
  233.                 Else
  234.                   Begin
  235.                     If IgnoreStr then
  236.                       IgnoreStr := False
  237.                     Else
  238.                       StrExp := Not(StrExp);
  239.                   End;
  240.               End;
  241.  
  242.             If StrExp then
  243.               OutPut(Ch)
  244.             Else
  245.               Case Ch Of
  246.                 '{'  : If (LookAhead(1) = '$') then
  247.                          Process_Directive
  248.                        else
  249.                          Process_Remark;
  250.                 '('  : If (LookAhead(1) = '*') then
  251.                          Begin
  252.                            If (LookAhead(2) = '$') then
  253.                              Process_Directive
  254.                            else
  255.                              Process_Remark
  256.                          End
  257.                        Else
  258.                          OutPut(Ch);
  259.               Else
  260.                 OutPut(Ch);
  261.               End; { Case }
  262.           Until (Eof(InFil)) and (LinePos = Length(Data));
  263.       PrintLine;
  264.           Close(InFil);
  265.           Dec(IncludeLevel);
  266.           If (IncludeLevel = 0) then
  267.             Page(Lst);
  268.         End
  269.       Else
  270.         Writeln(#7,'Can''t process the file: ',Fil);
  271.     End
  272.   Else
  273.     Writeln('Include-level ',IncludeLevel,' is too deep.');
  274. End; { Process_File }
  275.  
  276.  
  277. Var
  278.         Name    : String;
  279.         X       : Byte;
  280. BEGIN { Main }
  281.   Writeln('HighSpeed Pascal print program.');
  282.   Writeln;
  283.   If ParamCount = 0 then
  284.     Begin
  285.       Write('Enter name of program to print: ');
  286.       Readln(Name);
  287.       Process_File(Name,True);
  288.     End
  289.   Else
  290.     For X := 1 to ParamCount Do
  291.       Begin
  292.         Writeln('Printing: ',ParamStr(x));
  293.         Process_File(ParamStr(X),True);
  294.       End;
  295. END.
  296.